perm filename DRAWSM.OLD[DRW,LCS] blob
sn#396829 filedate 1978-11-17 generic text, type T, neo UTF8
SUBROUTINE DRAWIT
COMMON/ED/K,NEXT,NN,NX,NY,J
COMMON /RZ/RSZ,IPLT,RJB,CENTR
COMMON /RC/MCLEF(400),IST(4000)
COMMON/ZN/SCLEF(400,2),DDD
COMMON/LL/LL
COMMON/JJJ/JJJ
DIMENSION ITEM(20)
EQUIVALENCE(MM,SCLEF(1,1)),(W,IST(4000))
DATA RN/15./
CC CALL ACCPOG(1)
C DISPLAYS OLD ITEM WITHOUT FILLER
CC CALL DPYOUT(1)
REL=-1
JC=0
KE=-1
JCL=0
RJ=1
IF(MM.EQ.0)GO TO 20
J=MM
JX=-1
JCL=MM
NX=SCLEF(MM,1)
NY=SCLEF(MM,2)
GO TO 120
CC20 IF(JF.EQ.0)J=1
20 J=1
JZ=J
2 NX=RJB*RSZ
NY=CENTR*RSZ
121 JX=0
120 NZ=-1
JC=1
RL=NX
RM=NY
C L AND M ARE USED AS CONSTANTS WHEN RESETTING CURSOR
44 CALL SETCUR(NX,NY,0)
83 S=0
4 IF(S)GO TO 81
CJ NO MORE LIGHT PEN SELECTION. IF(K.EQ.'E')GO TO 700
IF(K.EQ.'E')GO TO 79
C BYPASS FOR EDITING.
45 FORMAT(' <CR> SETS POINT ',$)
TYPE 45
ACCEPT 144,K,ZK,KK
IF(ZK.NE.'E')GO TO 344
REL=0
C TYPE REL FOR RELATIVE VECTORS, O=ORDINARY
GO TO 4
344 IF(K.NE.'O')GO TO 244
REL=-1
GO TO 4
144 FORMAT(3A1)
244 IF(ZK.NE.'M')GO TO 444
C TYPE SM TO SMOOTH, SMX=ERASE STRAIGHT LINES TEMPORARILY.
MCLEF(1)=J
CALL SMOOTH(KK)
GO TO 4
444 IF(ZK.NE.'X')GO TO 445
MCLEF(2)=MCLEF(2)+200000000
K='X'
GO TO 3
445 REREAD 1,K,ZK,XK
IF(K.LE.' ')GO TO 40
REREAD 11,RJ,RK,XK
JMPR=0
IF(XK.EQ.1)K='J'
C TYPE 3RD NUM=1 FOR JUMPS
IF(XK.EQ.2)K='F'
C IF 3RD NUM=2 -- BEGIN FILL SECTION
41 QJ=RJ
QK=RK
IF(REL)GO TO 141
241 X=X+QJ*RSZ
Y=Y+QK*RSZ
NX=X
NY=Y
GO TO 48
141 NX=GTPT(RJ,RJB)
NY=GTPT(RK,CENTR)
X=NX
Y=NY
GO TO 481
40 KK=ZK
C B=BACKUP, J=JUMP, CR=SET POINT, X=EXIT, LRUD-N
C F=FILL IT, H=GO TO HOME-NUM, N=GO TO NEXT(AFTER AN 'H')
C Z=ZERO IN ON NEARBY POINT, P=GO TO PREVIOUS, C=CLOSE THE AREA
C D=EXTEND DRAWING, F=START FILLER OUTLINE, SM=SMOOTH IT
C TYPE 'FX' TO FILL ORIGINAL OUTLINE AND EXIT.
C L,R,U,D + NUM MOVES LAST POINT ENTERED.
IF(ZK.NE.0)NZ=-1
C WILL STAY IN "Z" MODE UNLESS NUMBER APPEARS.
JMPR=0
JCX=2
C JCX IS FOR "ZEROING-IN" SECTION AND EDIT SECTION
C FOR SHIFTS OF "JUMPS"
IF(K.EQ.'B')GO TO 22
CC IF(K.EQ.'P')GO TO 56
IF(K.EQ.'C')GO TO 51
IF(K.EQ.'X')GO TO 3
IF(K.EQ.' ')GO TO 47
IF(K.EQ.'J')GO TO 47
IF(K.EQ.'Z')GO TO 47
IF(K.EQ.'S')GO TO 79
IF(K.EQ.'F')GO TO 47
CC555 IF(K.NE.'N')GO TO 7
C****** NO MORE 'N' OR 'P' ******
IF(K.NE.'H')GO TO 7
CC55 KK=NEXT
CC GO TO 52
CC56 KK=NEXT-2
52 IF(KK.LE.1)KK=2
X=SCLEF(KK,1)
Y=SCLEF(KK,2)
NEXT=KK+1
IF(KE)GO TO 48
RX=X
RY=Y
58 IF(NEXT.GT.J+1)GO TO 44
NN=JA-1
CALL ITYP
CALL EDTYP(K,X,Y,JJJ)
C TYPE "A" OR ":" TO ALTER
C TYPE "G"=GROUP CHANGE) TO MAKE RELATIVE CHANGE STICK
C , THEN <CR>S. ANY OTHER LETTER TO ESCAPE
IF(K.NE.'J')GO TO 573
C J=JUMP TO NEXT 'JUMP'
DO 574 K=NEXT,J
574 IF(MCLEF(K).GE.100000000)GO TO 575
575 X=K-NEXT+1
GO TO 82
573 IF(K.LT.'-')GO TO 1573
C NEXT FOR NUMBERS ONLY -- FOR STEP AHEAD AND BACK
2573 REREAD 11,X
GO TO 82
1573 IF(K.NE.'B')GO TO 570
X=-X
GO TO 82
570 IF(K.NE.' ')GO TO 1570
IF(S)GO TO 81
1570 IF(K.EQ.'S')GO TO 82
C S=STEP AHEAD(N) (-N OR B GOES BACK)
IF(K.EQ.'X')GO TO 3
IF(K.NE.'M'.AND.K.NE.'R')GO TO 572
C M OR R ALONE WILL MOVE LAST SET OF POINTS MOVED. BUT BE CAREFUL!
LL=0
IF(X+Y.EQ.0)GO TO 580
IF(X.OR.Y.EQ.0)GO TO 577
C "M -N1, N2, N3" MOVES WHOLE BLOCKS (OR "M N1 0")
C OR USE 'R' FOR 'M' TO ROTATE GROUP OF POINTS
C TO SET ITEM # N2≠0, SETS ITEM # TO N3 IF N3≠0.
NY=Y-X+2
NX=X+1
576 MX=NX
MY=NY
CC IF(K.EQ.'R')MY=-MY
CC580 NY=MY
580 CALL SHIFT(MCLEF(MX),MY,K)
C TO MOVE SEGS MX THROUGH MY.
CALL CLRPOG(1)
CALL POG1
CALL RDRAW(2,MCLEF(1),MCLEF)
CALL DPYOUT(1)
GO TO 58
577 NX=ABS(X)
IF(Y.NE.0)GO TO 578
CALL UNPACK(NX,NX,NY,ITEM)
GO TO 576
578 NY=ABS(Y)
IF(JJJ.NE.0)GO TO 579
IK=IK+1
TYPE 46,IK
JJJ=IK
IF(JJJ.GT.10)GO TO 58
CC579 JB=NX
579 LL=0
NY=NY-NX+2
NX=NX+1
JB=NX
CALL REPACK(JJJ,JB,NY,ITEM)
GO TO 576
572 MCLEF(1)=J
IF(K.EQ.'F')GO TO 470
C TAKE OUT OTHER 'F'S IN DREDIT*****
571 CALL DREDIT
59 X=RX
Y=RY
KE=-1
NX=0
NY=0
GO TO 170
C THIS WRECKS "CLOSE"
470 MCLEF(NEXT-1)=MCLEF(NEXT-1)+200000000
K='X'
GO TO 34
47 IF(REL.EQ.0)GO TO 22
C IF IN "REL" MODE TYPE "O" BEFORE USING LTPEN
CALL RDCUR(NX,NY)
X=NX
Y=NY
IF((K.NE.'Z'.AND.NZ).OR.K.EQ.'J'.OR.K.EQ.'F')GO TO 48
NZ=0
DO 54 K=JCX,JCL
IF(ABS(SCLEF(K,1)-X).GT.RN.OR.ABS(SCLEF(K,2)-Y).GT.RN)
1 GO TO 54
KK=K
GO TO 52
54 CONTINUE
IF(KE)GO TO 48
C KE=-1 = DRAW MODE (NOT EDIT)
TYPE 154
GO TO 4
154 FORMAT(' NO POINT FOUND ')
C ABOVE FOR INITIAL MOVEMENT OF CURSOR
51 X=RX
Y=RY
48 RJ=STPT(X,RJB)
RK=STPT(Y,CENTR)
481 SK=RK
J=J+1
551 SJ=RJ
C DO I NEED RJ,RK ANYWHERE?? YES - AT REPACK
451 LL=0
IF(K.EQ.'J')LL=100000000
C J=JUMP
IF(K.NE.'F')GO TO 452
K='J'
253 LL=200000000
452 IJ=RJ
IK=RK
JCL=J
CALL REPACK(J,IJ,IK,MCLEF)
IF(MCLEF(J).NE.MCLEF(J-1).OR.J.EQ.2)GO TO 60
61 J=J-1
GO TO 4
60 SCLEF(J,1)=X
SCLEF(J,2)=Y
50 N=IST(2)
X=GTPT(SJ,RJB)
Y=GTPT(SK,CENTR)
NX=X
NY=Y
IF(K.EQ.'B')GO TO 5
IF(K.EQ.'J'.OR.JMPR.OR.JX.EQ.0)GO TO 6
CALL AVECT(NX,NY)
GO TO 5
6 CALL AIVECT(NX,NY)
JX=-1
JMPR=-1
C KZ IS FOR "CLOSE IT"
NZ=-1
RX=X
RY=Y
5 CALL DPYOUT(1)
L=J-1
TYPE 46,L,SJ,SK
170 CALL SETCUR(NX,NY,JC)
GO TO 4
74 FORMAT(' S(TEP) OR L(IGHT PEN)? ',$)
7 IF(K.NE.'E')GO TO 71
C E=EDIT
CC700 TYPE 74
CC ACCEPT 1,K,X
CC IF(K.NE.'L')GO TO 79
CC IF(ZK.NE.0)JCX=ZK
C SETS "ZEROING-IN" FIRST COUNTER
CC NZ=0
CC KE=0
C EDIT FLAG KE=0
CC TYPE 70
CC GO TO 44
CC70 FORMAT(' CHOOSE A POINT ')
71 IF(ZK.EQ.0)ZK=1
IF(K.EQ.'L'.OR.K.EQ.'D')ZK=-ZK
IF(K.EQ.'L'.OR.K.EQ.'R')GO TO 77
SK=ZK+SK
Y=GTPT(SK,CENTR)
GO TO 78
77 SJ=ZK+SJ
X=GTPT(SJ,RJB)
78 CALL BUP
J=J-1
GO TO 48
79 S=-1
JA=ZK-1
84 IF(JA.LT.2)JA=1
81 IF(K.NE.'D')JA=JA+1
IF(JA.GT.J)JA=J
X=SCLEF(JA,1)
Y=SCLEF(JA,2)
NX=X
NY=Y
NEXT=JA+1
CALL SETCUR(NX,NY,0)
GO TO 58
82 IF(X.EQ.0)X=-1
JA=JA-1+X
GO TO 84
22 IF(J.EQ.JZ)GO TO 4
C CAN'T BACKUP PAST 1 OR 'F'
J=J-1
122 CALL UNPACK(J,IJ,IK,MCLEF)
CALL BUP
SJ=IJ
SK=IK
IF(K.EQ.'B')GO TO 50
RJ=RJ+QJ
RK=RK+QK
GO TO 241
3 MCLEF(1)=J
IF(MCLEF(2).LT.100000000)MCLEF(2)=MCLEF(2)+100000000
34 CALL CLRCUR
IF(K.NE.'X')GO TO 120
1 FORMAT(A1,2F)
11 FORMAT(3F)
46 FORMAT(I3,'.)',2F6.0/)
END